home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / glisp / glisp.000 / GLISP.UNIX.TAR / closunix / closacc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-04-03  |  3.4 KB  |  195 lines
  1. /*                 GRAPHIC LISP            */
  2. /*        Scritto nel 1991-94 da Zoia Andrea Michele     */
  3. /*        Via Pergola #1 Tirano (SO) Tel. 0342-704210    */
  4. /* file closacc.c */
  5.  
  6. #include "clos.h"
  7.  
  8. node list_dup(l,fl)
  9. node l;
  10. int fl;
  11. {
  12.  node nret=NIL;
  13.  node n=NIL;
  14.  node prev=NIL;
  15.  
  16.  while(IS_CONS(l)){
  17.     n=node_make();
  18.     TYPE(n)|=NT_IS_CONS;
  19.     CONSLEFT(n)=CONSLEFT(l);
  20.     CONSRIGHT(n)=NIL;
  21.     if(prev==NIL){
  22.       nret=prev=n;
  23.     }else{
  24.       CONSRIGHT(prev)=n;
  25.       prev=n;
  26.     }
  27.     l=CONSRIGHT(l);
  28.  }
  29.  if(fl==DUP_LASTDUP && prev!=NIL)
  30.     CONSRIGHT(prev)=NIL;
  31.  return nret;
  32. }
  33.  
  34. len_t  listlen_func(l)
  35. node l;
  36. {
  37.  len_t i=0;
  38.  
  39.  while(IS_CONS(l)){
  40.    i++;
  41.    l=CONSRIGHT(l);
  42.  }
  43.  return i;
  44. }
  45.  
  46.  
  47. node list_elt(list,elt)
  48. node list;
  49. lsiz_t elt;
  50. {
  51.  /* prende l'elemento elt-esimo dalla lista list */
  52.  /* se non lo trova ritorna VOID */
  53.  /* elt deve essere >= 0 e list deve essere un CONS */
  54.  
  55.  while(elt--){
  56.    if(!IS_CONS(list))return VOID;
  57.    list=CONSRIGHT(list);
  58.  }
  59.  return CONSLEFT(list);
  60. }
  61.  
  62. node    calc_pointer(p)
  63. node_p *p;
  64. {
  65.  switch(p->type){
  66.     case P_ALLNODE:
  67.         return p->node;
  68.     case P_VALUE:
  69.         return VALUE(p->node);
  70.     case P_PLIST:
  71.         return PLIST(p->node);
  72.     case P_FUNC:
  73.         return FUNCTION(p->node);
  74.     case P_CONSLEFT:
  75.         return CONSLEFT(p->node);
  76.     case P_CONSRIGHT:
  77.         return CONSRIGHT(p->node);
  78.     case P_CLASS:
  79.         return CLASS(p->node);
  80.  }
  81.  error(E_BADPOINTER,ERR_MINTERNAL|ERR_TCRIT|ERR_PVOID,NULL);
  82.  return 0;
  83. }
  84.  
  85.  
  86. int    find_in_alist(nin,nout,alist)
  87. node    nin;
  88. node_p    *nout;
  89. node    alist;
  90. {
  91.  /* trova in alist il nodo con nome 'nin' e restituisce il suo valore */
  92.  /*     se non lo trova ritorna ERROR */
  93.  while(IS_CONS(alist)){
  94.     if(CONSLEFT(CONSLEFT(alist))==nin){
  95.         nout->type=P_CONSRIGHT;
  96.         nout->node=CONSLEFT(alist);
  97.         return OK;
  98.     }
  99.     alist=CONSRIGHT(alist);
  100.  }
  101.  return ERROR;
  102. }
  103.  
  104. node    put_in_alist(nname,nvalue,alist)
  105. node nname;
  106. node nvalue;
  107. node alist;
  108. {
  109.  /* inserisce (nn . nv) in testa ad alist e la ritorna */
  110.  node n1=node_make();
  111.  node n2=node_make();
  112.  
  113.  TYPE(n1)|=NT_IS_CONS;
  114.  TYPE(n2)|=NT_IS_CONS;
  115.  
  116.  CONSLEFT(n1)=n2;
  117.  CONSRIGHT(n1)=alist;
  118.  CONSLEFT(n2)=nname;
  119.  CONSRIGHT(n2)=nvalue;
  120.  return n1;
  121. }
  122.  
  123. int     chk_alist(alist)
  124. node alist;
  125. {
  126.  /* controlla se alist e' una lista di cons  */
  127.  /* cioe' se alist==( (name . xx) (name . xx) .... ) */
  128.  
  129.  node a=alist;
  130.  
  131.  while(a!=NIL)
  132.     if(    IS_CONS(a)&&IS_CONS(CONSLEFT(a))&&
  133.         IS_NAME(CONSLEFT(CONSLEFT(a)))&&
  134.         HAS_NAME(CONSLEFT(CONSLEFT(a))))
  135.  
  136.         a=CONSRIGHT(a);
  137.     else
  138.                 return ERROR;
  139.  return OK;
  140. }
  141.  
  142.  
  143.  
  144.  
  145. void internal_setf(name,value,genv,lenv)
  146. node name;
  147. node value;
  148. node genv;
  149. node lenv;
  150. {
  151.  node_p nout;
  152.  if(find_in_alist(name,&nout,lenv)){
  153.    /* name non e' nel local-environment */
  154.    if(find_in_alist(name,&nout,genv)){
  155.      /* name non e' nel global-environment */
  156.      VALUE(name)=value;
  157.  
  158. /*REVISIONE: se si setta una variabile defvar allora va preservato HAS_BIND*/
  159.      if(HAS_BIND(name) || HAS_VALUE(name))return;  
  160. /*_________*/
  161.  
  162.      TYPE(name)|=NT_HAS_VALUE;
  163.      return;
  164.    }
  165.  }
  166.  CONSRIGHT(nout.node)=value;
  167. }
  168.  
  169.  
  170.  
  171. void internal_update_environment(name,value,genv,lenv)
  172. node name;
  173. node value;
  174. node *genv;
  175. node *lenv;
  176. {
  177.  /* aggiunge la coppia name,value all'environment */
  178.  if(HAS_VALUE(name)){
  179.    /* name e' una variabile GLOBALE */
  180.    VALUE(name)=value;
  181.    return;
  182.  }
  183.  
  184.  if(HAS_BIND(name)){
  185.    /* name e' una variabile SPECIALE ''(defvar name),, */
  186.    *genv=put_in_alist(name,value,*genv);
  187.    return;
  188.  }
  189.  
  190.  /* name e' una variabile LOCALE */
  191.  *lenv=put_in_alist(name,value,*lenv);
  192. }
  193.  
  194.  
  195.